# msgbox.tcl -- # # Implements messageboxes for platforms that do not have native # messagebox support. # # SCCS: @(#) msgbox.tcl 1.8 97/07/28 17:20:01 # # Copyright (c) 1994-1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # tkMessageBox -- # # Pops up a messagebox with an application-supplied message with # an icon and a list of buttons. This procedure will be called # by tk_messageBox if the platform does not have native # messagebox support, or if the particular type of messagebox is # not supported natively. # # This procedure is a private procedure shouldn't be called # directly. Call tk_messageBox instead. # # See the user documentation for details on what tk_messageBox does. # proc tkMessageBox {args} { global tkPriv tcl_platform set w tkPrivMsgBox upvar #0 $w data # # The default value of the title is space (" ") not the empty string # because for some window managers, a # wm title .foo "" # causes the window title to be "foo" instead of the empty string. # set specs { {-default "" "" ""} {-icon "" "" "info"} {-message "" "" ""} {-parent "" "" .} {-title "" "" " "} {-type "" "" "ok"} } tclParseConfigSpec $w $specs "" $args if {[lsearch {info warning error question} $data(-icon)] == -1} { error "invalid icon \"$data(-icon)\", must be error, info, question or warning" } if {$tcl_platform(platform) == "macintosh"} { if {$data(-icon) == "error"} { set data(-icon) "stop" } elseif {$data(-icon) == "warning"} { set data(-icon) "caution" } elseif {$data(-icon) == "info"} { set data(-icon) "note" } } if ![winfo exists $data(-parent)] { error "bad window path name \"$data(-parent)\"" } case $data(-type) { abortretryignore { set buttons { {abort -width 6 -text Abort -under 0} {retry -width 6 -text Retry -under 0} {ignore -width 6 -text Ignore -under 0} } } ok { set buttons { {ok -width 6 -text OK -under 0} } if {$data(-default) == ""} { set data(-default) "ok" } } okcancel { set buttons { {ok -width 6 -text OK -under 0} {cancel -width 6 -text Cancel -under 0} } } retrycancel { set buttons { {retry -width 6 -text Retry -under 0} {cancel -width 6 -text Cancel -under 0} } } yesno { set buttons { {yes -width 6 -text Yes -under 0} {no -width 6 -text No -under 0} } } yesnocancel { set buttons { {yes -width 6 -text Yes -under 0} {no -width 6 -text No -under 0} {cancel -width 6 -text Cancel -under 0} } } default { error "invalid message box type \"$data(-type)\", must be abortretryignore, ok, okcancel, retrycancel, yesno or yesnocancel" } } if [string compare $data(-default) ""] { set valid 0 foreach btn $buttons { if ![string compare [lindex $btn 0] $data(-default)] { set valid 1 break } } if !$valid { error "invalid default button \"$data(-default)\"" } } # 2. Set the dialog to be a child window of $parent # # if [string compare $data(-parent) .] { set w $data(-parent).__tk__messagebox } else { set w .__tk__messagebox } # 3. Create the top-level window and divide it into top # and bottom parts. catch {destroy $w} toplevel $w -class Dialog wm title $w $data(-title) wm iconname $w Dialog wm protocol $w WM_DELETE_WINDOW { } wm transient $w $data(-parent) if {$tcl_platform(platform) == "macintosh"} { unsupported1 style $w dBoxProc } frame $w.bot pack $w.bot -side bottom -fill both frame $w.top pack $w.top -side top -fill both -expand 1 if {$tcl_platform(platform) != "macintosh"} { $w.bot configure -relief raised -bd 1 $w.top configure -relief raised -bd 1 } # 4. Fill the top part with bitmap and message (use the option # database for -wraplength so that it can be overridden by # the caller). option add *Dialog.msg.wrapLength 3i widgetDefault label $w.msg -justify left -text $data(-message) pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m if {$data(-icon) != ""} { label $w.bitmap -bitmap $data(-icon) pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m } # 5. Create a row of buttons at the bottom of the dialog. set i 0 foreach but $buttons { set name [lindex $but 0] set opts [lrange $but 1 end] if ![string compare $opts {}] { # Capitalize the first letter of $name set capName \ [string toupper \ [string index $name 0]][string range $name 1 end] set opts [list -text $capName] } eval button $w.$name $opts -command [list "set tkPriv(button) $name"] if ![string compare $name $data(-default)] { $w.$name configure -default active } pack $w.$name -in $w.bot -side left -expand 1 \ -padx 3m -pady 2m # create the binding for the key accelerator, based on the underline # set underIdx [$w.$name cget -under] if {$underIdx >= 0} { set key [string index [$w.$name cget -text] $underIdx] bind $w "$w.$name invoke" bind $w "$w.$name invoke" } incr i } # 6. Create a binding for on the dialog if there is a # default button. if [string compare $data(-default) ""] { bind $w "tkButtonInvoke $w.$data(-default)" } # 7. Withdraw the window, then update all the geometry information # so we know how big it wants to be, then center the window in the # display and de-iconify it. wm withdraw $w update idletasks set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ - [winfo vrootx [winfo parent $w]]] set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ - [winfo vrooty [winfo parent $w]]] wm geom $w +$x+$y wm deiconify $w # 8. Set a grab and claim the focus too. set oldFocus [focus] set oldGrab [grab current $w] if {$oldGrab != ""} { set grabStatus [grab status $oldGrab] } grab $w if [string compare $data(-default) ""] { focus $w.$data(-default) } else { focus $w } # 9. Wait for the user to respond, then restore the focus and # return the index of the selected button. Restore the focus # before deleting the window, since otherwise the window manager # may take the focus away so we can't redirect it. Finally, # restore any grab that was in effect. tkwait variable tkPriv(button) catch {focus $oldFocus} destroy $w if {$oldGrab != ""} { if {$grabStatus == "global"} { grab -global $oldGrab } else { grab $oldGrab } } return $tkPriv(button) }